unit ModDd;

{$mode objfpc}{$H+}

interface
uses Classes, SysUtils;
Type
{Дерево}
     Tel=integer;
     Tvd=^Der;
     Der=Record
      Nv:integer;
      Dv:Tel;
      Vl:Tvd;
      Vr:Tvd;
     end;
{Стек}
     Tvst=^St;
      St=Record
      Vd:Tvd;
      Vst:Tvst;
     end;
{Черга}
     Tvch=^Ch;
     Ch=Record
      Vd:Tvd;
      Zv:integer;
      Vch:Tvch;
     end;

 Procedure Vstek(var S:Tvst; Vkd:Tvd);
 Procedure Izstek(var S:Tvst; var Vkd:Tvd);
 Function Pustostek(var S:Tvst):Boolean;
 Procedure Ochstek(var S:Tvst);
 Procedure Vchr(var pch,kch:Tvch; Vkd:Tvd; zv:integer);
 Procedure Izchr(var pch,kch:Tvch; var Vkd:Tvd; var zv:integer);
 Function Pustochr(var pch,kch:Tvch):Boolean;
 Procedure Kopchr(var pch,kch,pch1,kch1:Tvch);
 Procedure Stvder(var T:Tvd; nd:integer; dd:Tel; zv:integer;
                              var  pr:integer);
 Procedure Drukder(var T:Tvd; var Lst:TStringList);
 Procedure DrukVidDer(var T:Tvd; var Lst:TStringList);
 Function SumDR(var T:Tvd):Tel;

 implementation

Var 	T:Tvd=nil;	{Вказівник на корінь дерева}
	S:Tvst=nil;	{Вказівник на вершину стеку}
	pch:Tvch=nil;	{Вказівник на початок черги}
	kch:Tvch=nil;	{Вказівник на кінець черги}

{Процедура включення в стек}
 Procedure Vstek(var S:Tvst; Vkd:Tvd);
 var q:Tvst;
  begin
  new(q);  q^.vd:=vkd;  q^.vst:=s;  s:=q;
 end;

{Процедура вибору із стеку}
 Procedure Izstek(var S:Tvst; var Vkd:Tvd);
 var q:Tvst;
  begin
  q:=s;  Vkd:=q^.vd;  s:=q^.vst;  dispose(q);
 end;

{Функція перевірки стеку}
 Function Pustostek(var S:Tvst):Boolean;
  begin
  if s=nil then Result:=false else Result:=true;
  end;

{Процедура очистки стеку}
 Procedure Ochstek(var S:Tvst);
  var q:Tvst;
  begin
   while s<>nil do
  begin  q:=s;  s:=s^.vst;  dispose(q);  end;
 end;

{Процедура установки в чергу}
 Procedure Vchr(var pch,kch:Tvch; Vkd:Tvd; zv:integer);
 var q:Tvch;
  begin
  new(q);  q^.vd:=vkd;  q^.zv:=zv;  q^.vch:=nil;
  if pch=nil then begin pch:=q;kch:=q; end
     else begin kch^.vch:=q;kch:=q; end;
 end;

{Процедура вибору із черги}
  Procedure Izchr(var pch,kch:Tvch; var Vkd:Tvd; var zv:integer);
 var q:Tvch;
  begin
  q:=pch;  Vkd:=q^.vd;  zv:=q^.zv;  pch:=q^.vch;  dispose(q);
  end;

{Функція перевірки черги}
 Function Pustochr(var pch, kch:Tvch):Boolean;
 begin
 if pch=nil then Result:=false else Result:=true;
 end;

{Процедура копіювання черги}
Procedure Kopchr(var pch,kch,pch1,kch1:Tvch);
 var p,q:Tvch;
  begin
  pch:=nil;  kch:=nil;  q:=pch1;
  while q<>nil do
  begin  new(p);  p^.Vd:=q^.vd;  p^.Zv:=q^.zv;  p^.Vch:=q^.vch;
  if pch=nil then begin pch:=p;kch:=p;end  else kch:=p;
  pch1:=q^.vch;
  dispose(q);
  q:=pch1;
  end;
  end;

{Процедура створення бінарного дерева}
 Procedure Stvder(var T:Tvd; nd:integer; dd:Tel; zv:integer; var pr:integer);
 var  p,q:Tvd;
        S:Tvst;
        F:Boolean;
 begin
  S:=nil;		{Створення вузла дерева}
  new(q);   q^.Nv:=nd;   q^.Dv:=dd;   q^.Vl:=nil;   q^.Vr:=nil;
   if T=nil then begin T:=q; pr:=0;end {Корінь дерева}
   else
   {Пошук вузла до якого потрібно під’єднатися}
   begin pr:=2; f:=true; p:=T;
    while (p<>nil) and f do
    begin
    if p^.Nv=zv then   begin   	{Включення вузла}
     if p^.Vl=nil then	{Лівий зв'язок}
     begin pr:=0; f:=false; p^.vl:=q;end
    else			 {Правий зв'язок}
    begin  if p^.Vr=nil then  begin pr:=0; f:=false; p^.vr:=q;end
     else	 begin f:=false; pr:=1;end; {Зв’язки зайняті}
    end;
    end
    else   begin		{Перехід до наступного вузла}
    if p^.Vl<>nil then      {Йти вліво, праву вітку, якщо є, у стек}
    begin   if p^.Vr<>nil then Vstek(S, p^.Vr);  p:=p^.Vl;  end
    else			{Йти вправо якщо є зв'язок}
    begin  if p^.Vr<>nil then begin p:=p^.Vr; end
    else			{Зв'язків немає вибрати із стеку}
    begin    if Pustostek(S) then Izstek(S, p)
     else p:=nil; 		{Стек порожній}
      end;
     end;
     end;
    end;
    end;
    if pr>0 then Dispose(q); {Елемент не включено}
    if S<>nil then Ochstek(S);      {Очистка стеку}
  end;

{Процедура виведення бінарного дерева}
Procedure Drukder(var T:Tvd; var Lst:TStringList);
  var   nr,zv:integer;
        Vd:Tvd;
        c:string;
         pch,kch:Tvch;
         pch1,kch1:Tvch;
   begin
   pch:=nil;  pch1:=nil;
    if T=nil then Lst.Add('Дерево порожнє')
    else   begin  nr:=0;
    {Корінь в чергу}
     Vchr(pch,kch, T, 0);
     while Pustochr(pch,kch) do
     begin
     while Pustochr(pch,kch) do
     begin  Lst.Add(IntToStr(nr)+' - ранг');  c:='';
     Izchr(pch, kch, Vd, zv);
     c:=c+'('+IntToStr(Vd^.Nv)+','+IntToStr(Vd^.Dv)+', '+IntToStr(Zv)+'); ';
     if Vd^.Vl<>nil then Vchr(pch1,kch1, Vd^.Vl, Vd^.Nv);
     if Vd^.Vr<>nil then  Vchr(pch1,kch1, Vd^.Vr, Vd^.Nv);
     end;
     Lst.Add(C);
     nr:=nr+1;
     Kopchr( pch,kch,pch1,kch1);
      end;
      end;
   end;

{Процедура виведення відємних елементів бінарного дерева}
Procedure DrukVidDer(var T:Tvd; var Lst:TStringList);
  var   nr,zv:integer;
        Vd:Tvd;
        c:string;
         pch,kch:Tvch;
         pch1,kch1:Tvch;
   begin
   pch:=nil;  pch1:=nil;
    if T=nil then Lst.Add('Дерево порожнє')
    else
    begin
    nr:=0;
    {Корінь в чергу}
     Vchr(pch,kch, T, 0);
     while Pustochr(pch,kch) do
     begin
          while Pustochr(pch,kch) do
                begin
                     Lst.Add(IntToStr(nr)+' - ранг');  c:='';
                     Izchr(pch, kch, Vd, zv);
                     c:=c+'('+IntToStr(Vd^.Nv)+','+IntToStr(Vd^.Dv)+', '+IntToStr(Zv)+'); ';
                     if Vd^.Vl<>nil then Vchr(pch1,kch1, Vd^.Vl, Vd^.Nv);
                     if Vd^.Vr<>nil then  Vchr(pch1,kch1, Vd^.Vr, Vd^.Nv);
                end;
                if Vd^.Dv < 0 then
                   Lst.Add(C);
                nr:=nr+1;
                Kopchr( pch,kch,pch1,kch1);
      end;
      end;
   end;

{Функція обчислення суми вузлів бінарного дерева}
 Function SumDR(var T:Tvd):Tel;
  var  p:Tvd;
  begin
    s:=nil; Result:=0;    p:=T;
    while (p<>nil)  do
    begin   Result:=Result+p^.Dv;
    {Перехід до наступної вершини}
    if p^.Vl<>nil then {Є лівий зв'язок, правий у стек, йти вліво}
     begin  if p^.Vr<>nil then Vstek(S, p^.Vr);  p:=p^.Vl;  end
      else   begin     if p^.Vr<>nil then   p:=p^.Vr {Йти вправо}
         else    {Немае обох звязків, взяти із стеку}
       if Pustostek(S) then Izstek(S, p)
       else p:=nil;        {Стек порожній кінець перегляду}
     end;
    end;
  end;
end.
